home *** CD-ROM | disk | FTP | other *** search
/ Developer CD Series 1993…stman Always Clicks Twice / ADC Developer CD (1993-01) (''The Postman Always Clicks Twice'')_iso / Dev.CD 199301.iso / Development Platforms / LISP Related / LISP Goodies / McCartney-library 1.1 / CODE / oodles-files / simple-view-ce.lisp < prev   
Encoding:
Text File  |  1992-09-02  |  4.5 KB  |  128 lines  |  [TEXT/CCL2]
  1. (in-package :oou)
  2. ;(oou-provide :simple-view-ce)
  3. (provide :simple-view-ce)
  4. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  5. ;; simple-view-ce.Lisp
  6. ;;
  7. ;; Copyright © 1992 Northwestern University Institute for the Learning Sciences
  8. ;; All Rights Reserved
  9. ;;
  10. ;; author: Michael S. Engber
  11. ;;
  12. ;; methods for the view class
  13. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  14.  
  15. (export '(focusing-view focused-corners view-portBits
  16.           offset-view-position
  17.           view-hide view-show view-shown-p view-shown-position
  18.           hilite-view
  19.           erase-corners erase-view
  20.           view-to-global global-to-view
  21.           view-to-window window-to-view
  22.           view-window-corners view-global-corners
  23.           ))
  24.  
  25. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  26.  
  27. (eval-when (:compile-toplevel :load-toplevel :execute)
  28.   
  29.   (defconstant $di-hidden-const  8192)
  30.   (defconstant $di-hide-h-offset 16384)
  31.   
  32.   )
  33.  
  34. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  35.  
  36. (defmethod focusing-view ((sv simple-view)) (view-container sv))
  37. (defmethod focusing-view ((v view)) v)
  38.  
  39. (defmethod focused-corners ((sv simple-view)) (view-corners sv))
  40. (defmethod focused-corners ((v view))         (values #@(0 0) (view-size v)))
  41.  
  42. (defmethod view-portBits ((sv simple-view))
  43.   (pref (wptr sv) :GrafPort.portBits))
  44.  
  45. (defmethod offset-view-position ((sv simple-view) dh &optional dv)
  46.   (set-view-position sv (add-points (view-position sv) (make-point dh dv))))
  47.  
  48. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  49. ;; hiding views (as per HideDItem & ShowDItem IM IV p.59)
  50.  
  51. (defmethod view-hide ((sv simple-view))
  52.   (when (view-shown-p sv)
  53.     (offset-view-position sv #.(make-point $di-hide-h-offset 0))))
  54.  
  55. (defmethod view-show ((sv simple-view))
  56.   (unless (view-shown-p sv)
  57.     (offset-view-position sv #.(make-point (- $di-hide-h-offset) 0))))
  58.  
  59. (defmethod view-shown-p ((sv simple-view))
  60.   (< (point-h (view-position sv)) #.$di-hidden-const))
  61.  
  62. (defmethod view-shown-position ((sv simple-view))
  63.   (if (view-shown-p sv)
  64.     (view-position sv)
  65.     (subtract-points (view-position sv) #.(make-point $di-hide-h-offset 0))))
  66.  
  67.  
  68. (defmethod erase-corners ((sv simple-view) topLeft botRight)
  69.   (rlet ((r :Rect :topLeft topLeft :botRight botRight))
  70.     (with-macptrs ((rgn (#_NewRgn)))
  71.       (#_RectRgn rgn r)
  72.       (let ((erase-rgn (window-erase-region (view-window sv))))
  73.         (#_UnionRgn rgn erase-rgn erase-rgn))
  74.       (#_DisposeRgn rgn))))
  75.  
  76. (defmethod erase-view ((sv simple-view))
  77.   (multiple-value-call #'erase-corners sv (view-window-corners sv)))
  78.  
  79. ;; hilite-view is special purpose functions for use in designing new
  80. ;; classes. They were designed with efficiency in mind, rather
  81. ;; than robustness.
  82. ;;
  83. ;;Note: they do not focus the current view. They're intended
  84. ;;to be used in specializing methods (like view-draw-contents)
  85. ;;which take care of focussing the current view. For simple views
  86. ;;it be focused to view's container. For views it should be focused
  87. ;;to the view.
  88. ;;
  89. ;; Hiliting an already hilited view or un-hiliting a view that's
  90. ;; not hilited will not work with these default fns.
  91. ;;
  92. ;;
  93. (defmethod hilite-view ((sv simple-view) hilite-flag)
  94. ;;Hilites the specified view. Specializations may use hilite-flag
  95. ;;to tell whether to hilite or un-hilite the item (t/nil). It is
  96. ;;not used here because InvertRect is reversable.
  97.   (declare (ignore hilite-flag))
  98.   (multiple-value-bind (topLeft botRight) (focused-corners sv)
  99.     (rlet ((r :Rect :topLeft topLeft :botRight botRight))
  100.       (#_BitClr (%int-to-ptr #$hiliteMode) #$pHiliteBit)
  101.       (#_InvertRect r))))
  102.  
  103. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  104. ;; coordinate conversions
  105.  
  106. (defmethod view-to-window ((sv simple-view) point)
  107.   (subtract-points point (view-origin sv)))
  108.  
  109. (defmethod window-to-view ((sv simple-view) point)
  110.   (add-points point (view-origin sv)))
  111.  
  112.  
  113. (defmethod view-to-global ((sv simple-view) point)
  114.   (add-points (view-position (view-window sv)) (subtract-points point (view-origin sv))))
  115.  
  116. (defmethod global-to-view ((sv simple-view) point)
  117.   (subtract-points (add-points point (view-origin sv)) (view-position (view-window sv))))
  118.  
  119.  
  120. (defmethod view-window-corners ((sv simple-view))
  121.   (let ((offset (subtract-points #@(0 0) (view-origin sv))))
  122.     (values offset (add-points (view-size sv) offset))))
  123.  
  124. (defmethod view-global-corners ((sv simple-view))
  125.   (let ((offset (subtract-points (view-position (view-window sv)) (view-origin sv))))
  126.     (values offset (add-points (view-size sv) offset))))
  127.  
  128.